Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/realse1a/form1.frm

Visual Basic Form | 1999-10-17 | 8.1 KB | 263 lines

VERSION 5.00
Begin VB.Form Form1
   Caption         =   "Form1"
   ClientHeight    =   2910
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   3030
   LinkTopic       =   "Form1"
   ScaleHeight     =   2910
   ScaleWidth      =   3030
   StartUpPosition =   3  'Windows Default
   Begin VB.TextBox txtBody
      Height          =   1215
      Left            =   0
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Vertical
      TabIndex        =   11
      Top             =   1200
      Width           =   3015
   End
   Begin VB.TextBox txtSubject
      Height          =   285
      Left            =   0
      TabIndex        =   10
      Text            =   "Subject"
      Top             =   960
      Width           =   3015
   End
   Begin VB.TextBox txtEmail
      Height          =   285
      Left            =   360
      TabIndex        =   8
      Text            =   "email_address of sender"
      Top             =   480
      Width           =   2655
   End
   Begin VB.TextBox txtSender
      Height          =   285
      Left            =   360
      TabIndex        =   6
      Text            =   "nickname of sender"
      Top             =   240
      Width           =   2655
   End
   Begin VB.TextBox txtICQNUM
      Height          =   285
      Left            =   360
      TabIndex        =   4
      Text            =   "ICQ_NUMBER"
      Top             =   0
      Width           =   2655
   End
   Begin VB.CommandButton Command2
      Caption         =   "Exit"
      Height          =   375
      Left            =   1560
      TabIndex        =   3
      Top             =   2520
      Width           =   1455
   End
   Begin VB.TextBox DataArrival
      Height          =   285
      Left            =   0
      TabIndex        =   2
      Top             =   3120
      Width           =   1095
   End
   Begin VB.CommandButton Command1
      Caption         =   "Send Message"
      Height          =   375
      Left            =   0
      TabIndex        =   1
      Top             =   2520
      Width           =   1455
   End
   Begin VB.TextBox Text1
      Height          =   1215
      Left            =   0
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Vertical
      TabIndex        =   0
      Top             =   3480
      Width           =   3015
   End
   Begin VB.Label Label3
      Caption         =   "email:"
      Height          =   255
      Left            =   0
      TabIndex        =   9
      Top             =   480
      Width           =   375
   End
   Begin VB.Label Label2
      Caption         =   "from:"
      Height          =   255
      Left            =   0
      TabIndex        =   7
      Top             =   240
      Width           =   375
   End
   Begin VB.Label Label1
      Caption         =   "to:"
      Height          =   255
      Left            =   0
      TabIndex        =   5
      Top             =   0
      Width           =   375
   End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private bTrans As Boolean
Private Sock As Integer
Private RC As Integer
Private Bytes As Integer
Private Const httpserver As String = "wwp.icq.com"
Public remotefile As String
'This is for the WaitforResponse Routine
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Private Function ReplaceText(object$, RepWhat$, RepWit$) As String
Dim bwah, bwh, temp1, temp2
On Error Resume Next
bwah = object$
    bwh = InStr(bwah, RepWhat$)
    If bwh <> 0 Then
 temp1 = Left$(bwah, bwh - 1)
 temp2 = Right$(bwah, Len(bwah) - (bwh))
 bwah = temp1 & RepWit$ & temp2
 GoTo la
    End If
NulDetect:
ReplaceText = bwah
End Function
Private Sub Command1_Click()
'build remote file string so to speak watch debug window
'to see what it ends up looking like if you are interested
remotefile = "/scripts/WWPMsg.dll?from=" & txtSender.Text
remotefile = remotefile & "&fromemail=" & txtEmail.Text
remotefile = remotefile & "&subject=" & ReplaceText(txtSubject.Text & "", Chr$(32), "+")
remotefile = remotefile & "&body=" & ReplaceText(txtBody.Text & "", Chr$(32), "+")
remotefile = remotefile & "&to=" & Val(txtICQNUM.Text) & "&"
Debug.Print remotefile & ""
Dim StartupData As WSADataType
Dim SocketBuffer As sockaddr
Dim IpAddr As Long
Dim StrWebPage As String, StrCommand As String
'Initialize the socket
RC = WSAStartup(&H101, StartupData)
RC = WSAStartup(&H101, StartupData)
Sock = socket(AF_INET, SOCK_STREAM, 0)
If Sock = SOCKET_ERROR Then
    Debug.Print "Cannot Create Socket."
    Exit Sub
End If
'Checks if the Hostname exists
If RC = SOCKET_ERROR Then Exit Sub
IpAddr = GetHostByNameAlias(httpserver)
If IpAddr = -1 Then
    Debug.Print "Unknown Host: " + httpserver
    Exit Sub
End If
'This part is responsible for the connection
'as well as setting port
SocketBuffer.sin_family = AF_INET
SocketBuffer.sin_port = htons(80)
SocketBuffer.sin_addr = IpAddr
SocketBuffer.sin_zero = String$(8, 0)
RC = connect(Sock, SocketBuffer, Len(SocketBuffer))
'If an error occured close the connection and
'send an error message to the text window
If RC = SOCKET_ERROR Then
        Debug.Print "Cannot Connect to " + httpserver + _
                            Chr$(13) + Chr$(10) + _
                            GetWSAErrorString(WSAGetLastError())
        closesocket Sock
        RC = WSACleanup()
        Exit Sub
End If
'Select Receive Window (textbox named DataArrival
RC = WSAAsyncSelect(Sock, DataArrival.hWnd, _
                        ByVal &H202, ByVal FD_READ Or FD_CLOSE)
    If RC = SOCKET_ERROR Then
        Debug.Print "Cannot Process Asynchronously."
        closesocket Sock
        RC = WSACleanup()
        Exit Sub
    End If
bTrans = True
DataArrival = ""
    'build the command to send to http server
  StrWebPage = remotefile
  StrCommand = "GET " + StrWebPage & vbCrLf '+ " HTTP/1.0" + vbCrLf
  StrCommand = StrCommand + "Accept: */*" + vbCrLf
  'StrCommand = StrCommand + "Accept: text/html" + vbCrLf
  'StrCommand = StrCommand + vbCrLf
  'send command to server
  WinsockSendData StrCommand & ""
Call WaitForResponse
End Sub
Private Sub WaitForResponse()
Dim Start As Long
Dim Tmr As Long
'Works with an Api Declaration because it's more precious
Start = timeGetTime
While Bytes > 0
    Tmr = timeGetTime - Start
    DoEvents ' Let System keep checking for incoming response

    'Wait 50 seconds for response
    If Tmr > 50000 Then
        MsgBox "SMTP service error, timed out while waiting for response", 64, "Error!"
        End
    End If
End Sub
Private Sub Command2_Click()
On Error Resume Next
    closesocket Sock
    RC = WSACleanup()
    End
End Sub
Private Sub DataArrival_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim MsgBuffer As String * 2048
On Error Resume Next
    If Sock > 0 Then
        'Receive up to 2048 chars
        Bytes = recv(Sock, ByVal MsgBuffer, 2048, 0)

        If Bytes > 0 Then


            If bTrans Then
            Text1.Text = Text1.Text & MsgBuffer
        ElseIf WSAGetLastError() <> WSAEWOULDBLOCK Then
            closesocket (Sock)
            RC = WSACleanup()
            Sock = 0
        End If
    End If
End If
Refresh
End Sub
Private Sub WinsockSendData(DatatoSend As String)
Dim RC As Integer
Dim MsgBuffer As String * 2048
MsgBuffer = DatatoSend
RC = send(Sock, ByVal MsgBuffer, Len(DatatoSend), 0)
'If an error occurs send an error message and
'reset the winsock
If RC = SOCKET_ERROR Then
    Debug.Print "Cannot Send Request." + _
                            Chr$(13) + Chr$(10) + _
                            Str$(WSAGetLastError()) + _
                            GetWSAErrorString(WSAGetLastError())
    closesocket Sock
    RC = WSACleanup()
    Exit Sub
End If
End Sub
Private Sub Form_Load()
End Sub